home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / strcase.scm < prev    next >
Text File  |  1999-04-19  |  2KB  |  51 lines
  1. ;;; "strcase.scm" String casing functions.
  2. ; Written 1992 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de)
  3. ;
  4. ; This code is in the public domain.
  5.  
  6. ; Modified by Aubrey Jaffer Nov 1992.
  7. ; Authors of the original version were Ken Dickey and Aubrey Jaffer.
  8.  
  9. ;string-upcase, string-downcase, string-capitalize
  10. ; are obvious string conversion procedures and are non destructive.
  11. ;string-upcase!, string-downcase!, string-capitalize!
  12. ; are destructive versions.
  13.  
  14. (define (string-upcase! str)
  15.   (do ((i (- (string-length str) 1) (- i 1)))
  16.       ((< i 0) str)
  17.     (string-set! str i (char-upcase (string-ref str i)))))
  18.  
  19. (define (string-upcase str)
  20.   (string-upcase! (string-copy str)))
  21.   
  22. (define (string-downcase! str)
  23.   (do ((i (- (string-length str) 1) (- i 1)))
  24.       ((< i 0) str)
  25.     (string-set! str i (char-downcase (string-ref str i)))))
  26.  
  27. (define (string-downcase str)
  28.   (string-downcase! (string-copy str)))
  29.  
  30. (define (string-capitalize! str)    ; "hello" -> "Hello"
  31.   (let ((non-first-alpha #f)        ; "hELLO" -> "Hello"
  32.     (str-len (string-length str)))    ; "*hello" -> "*Hello"
  33.     (do ((i 0 (+ i 1)))            ; "hello you" -> "Hello You"
  34.     ((= i str-len) str)
  35.       (let ((c (string-ref str i)))
  36.     (if (char-alphabetic? c)
  37.         (if non-first-alpha
  38.         (string-set! str i (char-downcase c))
  39.         (begin
  40.           (set! non-first-alpha #t)
  41.           (string-set! str i (char-upcase c))))
  42.         (set! non-first-alpha #f))))))
  43.  
  44. (define (string-capitalize str)
  45.   (string-capitalize! (string-copy str)))
  46.  
  47. (define string-ci->symbol
  48.   (if (equal? "a" (symbol->string 'a))
  49.       (lambda (str) (string->symbol (string-downcase str)))
  50.       (lambda (str) (string->symbol (string-upcase str)))))
  51.